home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 February: Tool Chest / Dev.CD Feb 94.toast / Tool Chest / Development Platforms / MCL Related / User Contributions / oodles-of-utils.sea / oodles-of-utils / objects-of-desire / room-with-a-view / te-view.lisp / te-view.lisp
Encoding:
Text File  |  1992-07-22  |  11.7 KB  |  284 lines  |  [TEXT/CCL2]
  1. (in-package :oou)
  2. (oou-provide :te-view)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; te-view.lisp
  5. ;;
  6. ;; Copyright © 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Cliff Chaput
  10. ;;
  11. ;; View containing te-di and scrollbars
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies :te-dim
  15.                   :frame-svm)
  16.  
  17. (export '(te-view
  18.           te-set-font te-selection te-set-selection
  19.           te-set-text-rsrc te-save-text-rsrc te-string
  20.           ))
  21.  
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23.  
  24. (defclass te-item (te-dim dialog-item) ())
  25.  
  26. (defclass te-view (frame-svm view)
  27.   ((te-item             :accessor te-item)
  28.    (te-v-scroll-bar     :accessor te-v-scroll-bar)
  29.    (te-h-scroll-bar     :accessor te-h-scroll-bar)
  30.    (te-v-scroll-bar-p   :initarg :te-v-scroll-bar-p
  31.                         :accessor te-v-scroll-bar-p)
  32.    (te-h-scroll-bar-p   :initarg :te-h-scroll-bar-p
  33.                         :accessor te-h-scroll-bar-p)
  34.    (te-scroll-bar-width :accessor te-scroll-bar-width
  35.                         :initarg :te-scroll-bar-width)
  36.    (te-init-string      :initarg :te-init-string
  37.                         :initarg :dialog-item-text
  38.                         :accessor te-init-string)
  39.    (te-init-rsrc        :initarg :te-init-rsrc
  40.                         :accessor te-init-rsrc)
  41.    (te-word-wrap-p      :accessor te-word-wrap-p
  42.                         :initarg :te-word-wrap-p)
  43.    (te-read-only-p      :accessor te-read-only-p
  44.                         :initarg :te-read-only-p)
  45.    (te-h-margin         :accessor te-h-margin
  46.                         :initarg :te-h-margin))
  47.   (:default-initargs
  48.     :te-init-string      "The horror…"
  49.     :te-word-wrap-p      t
  50.     :te-read-only-p      nil
  51.     :te-v-scroll-bar-p   t
  52.     :te-h-scroll-bar-p   nil
  53.     :te-scroll-bar-width 16
  54.     :te-h-margin         1
  55.     ))
  56.  
  57.  
  58. (defmethod initialize-instance :after ((self te-view) &rest initargs)
  59.   (declare (ignore initargs))
  60.   (when (te-v-scroll-bar-p self)
  61.     (multiple-value-bind (pos width length) (v-scroll-dimensions self)
  62.       (setf (te-v-scroll-bar self)
  63.             (make-instance 'scroll-bar-dialog-item
  64.               :view-container  self
  65.               :view-position   pos
  66.               :width           width
  67.               :length          length
  68.               :view-nick-name  :te-item-v-scroll))))
  69.  
  70.   (when (te-h-scroll-bar-p self)
  71.     (multiple-value-bind (pos width length) (h-scroll-dimensions self)
  72.       (setf (te-h-scroll-bar self)
  73.             (make-instance 'scroll-bar-dialog-item
  74.               :direction      :horizontal
  75.               :view-container self
  76.               :view-position  pos
  77.               :width          length
  78.               :length         width
  79.               :view-nick-name :te-item-h-scroll))))
  80.  
  81.   (setf (te-item self) (create-te-item self)))
  82.  
  83.  
  84. (defmethod set-view-size :after ((self te-view) h &optional v)
  85.   (declare (ignore h v))
  86.  
  87.   (set-view-size (te-item self) (te-item-size self))
  88.  
  89.   (when (slot-boundp self 'te-v-scroll-bar)
  90.     (multiple-value-bind (pos width length) (v-scroll-dimensions self)
  91.       (set-view-position (te-v-scroll-bar self) pos)
  92.       (set-scroll-bar-width (te-v-scroll-bar self) width)
  93.       (set-scroll-bar-length (te-v-scroll-bar self) length)))
  94.  
  95.   (when (slot-boundp self 'te-h-scroll-bar)
  96.     (multiple-value-bind (pos width length) (h-scroll-dimensions self)
  97.       (set-view-position (te-h-scroll-bar self) pos)
  98.       (set-scroll-bar-width (te-h-scroll-bar self) length)
  99.       (set-scroll-bar-length (te-h-scroll-bar self) width))))
  100.  
  101.  
  102. (defmethod v-scroll-dimensions ((self te-view))
  103.   (values
  104.    (make-point (- (point-h (view-size self)) (te-scroll-bar-width self)) 0)
  105.    (te-scroll-bar-width self)
  106.    (if (te-h-scroll-bar-p self)
  107.      (- (point-v (view-size self)) (te-scroll-bar-width self) -1)
  108.      (point-v (view-size self)))))
  109.  
  110.  
  111. (defmethod h-scroll-dimensions ((self te-view))
  112.   (values
  113.    (make-point 0 (- (point-v (view-size self)) (te-scroll-bar-width self)))
  114.    (if (te-v-scroll-bar-p self)
  115.      (- (point-h (view-size self)) (te-scroll-bar-width self) -1)
  116.      (point-h (view-size self)))
  117.    (te-scroll-bar-width self)))
  118.  
  119.  
  120. (defmethod create-te-item ((self te-view))
  121.   (let* ((h-scroll-bar (when (te-h-scroll-bar-p self)
  122.                          (list :te-h-scroll-bar :te-item-h-scroll)))
  123.          (v-scroll-bar (when (te-v-scroll-bar-p self)
  124.                          (list :te-v-scroll-bar :te-item-v-scroll)))
  125.          (init-rsrc (when (slot-boundp self 'te-init-rsrc)
  126.                       (list :te-init-rsrc (te-init-rsrc self))))
  127.          (final-args `(,@h-scroll-bar ,@v-scroll-bar ,@init-rsrc)))
  128.     
  129.     (apply #'make-instance 'te-item
  130.            :te-init-string (te-init-string self)
  131.            :allow-returns  t
  132.            :te-word-wrap-p (te-word-wrap-p self)
  133.            :te-read-only-p (te-read-only-p self)
  134.            :view-container self
  135.            :view-position  (make-point (te-h-margin self) 1)
  136.            :view-size      (te-item-size self)
  137.            :view-nick-name :te-item
  138.            final-args)))
  139.  
  140.  
  141. (defmethod te-item-size ((self te-view))
  142.   (subtract-points (view-size self)
  143.                    (make-point
  144.                     (+ (if (te-v-scroll-bar-p self) (te-scroll-bar-width self) 0) (* 2 (te-h-margin self)))
  145.                     (+ (if (te-h-scroll-bar-p self) (te-scroll-bar-width self) 1) 1))))
  146.  
  147.  
  148. ;;;Duplicated methods that just call the same methods on the te-item
  149.  
  150. (defmethod te-save-text-rsrc ((self te-view) &key rsrc-id rsrc-name)
  151.   (te-save-text-rsrc (te-item self) :rsrc-id rsrc-id :rsrc-name rsrc-name))
  152.  
  153. (defmethod te-set-text-rsrc ((self te-view) rsrc-id-or-name)
  154.   (te-set-text-rsrc (te-item self) rsrc-id-or-name))
  155.  
  156. (defmethod te-set-font ((self te-view) font-spec &key (font-color *black-color*) (mode #$doAll))
  157.   (te-set-font (te-item self) font-spec :font-color font-color :mode mode))
  158.  
  159. (defmethod te-selection ((self te-view))
  160.   (te-selection (te-item self)))
  161.  
  162. (defmethod te-set-selection ((self te-view) sel-start sel-end)
  163.   (te-set-selection (te-item self) sel-start sel-end))
  164.  
  165. (defmethod te-string ((self te-view))
  166.   (te-string (te-item self)))
  167.  
  168. (defmethod (setf te-string) (string (self te-view))
  169.   (setf (te-string (te-item self)) string))
  170.  
  171. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  172.  
  173. #|
  174.  
  175. (open-res-file "oou:examples;examples.rsrc")
  176. ;(close-res-file "oou:examples;examples.rsrc")
  177.  
  178. (defparameter *test-w* (make-instance 'window
  179.                          :view-size #@(410 200)
  180.                          :window-title "te-view test"
  181.                          :color-p t
  182.                          :view-subviews
  183.                          (list
  184.                           (make-instance 'te-view
  185.                             :view-position      #@(5 5)
  186.                             :view-size          #@(230 175)
  187.                             :view-nick-name     :te
  188.                             :te-init-rsrc       "example style text"
  189.                             :te-v-scroll-bar-p t
  190.                             ;:te-h-scroll-bar-p t
  191.                             :te-h-margin        5
  192.                             )
  193.                           (make-instance 'pop-up-menu
  194.                             :view-position #@(240 5)
  195.                             :view-size #@(160 20)
  196.                             :auto-update-default nil
  197.                             :menu-items (font-menu-items))
  198.                           (make-instance 'pop-up-menu
  199.                             :view-position #@(240 30)
  200.                             :view-size #@(160 20)
  201.                             :auto-update-default nil
  202.                             :menu-items (size-menu-items))
  203.                           (make-instance 'pop-up-menu
  204.                             :view-position #@(240 55)
  205.                             :view-size #@(160 20)
  206.                             :auto-update-default nil
  207.                             :menu-items (style-menu-items))
  208.                           (make-instance 'pop-up-menu
  209.                             :view-position #@(240 80)
  210.                             :view-size #@(160 20)
  211.                             :auto-update-default nil
  212.                             :menu-colors '(:menu-background 5592405)
  213.                             :menu-items (color-menu-items)
  214.                             ))))
  215.  
  216. (defun font-menu-items ()
  217.   `(,(make-instance 'menu-item :menu-item-title "Da Font")
  218.     ,(make-instance 'menu-item :menu-item-title "-" :disabled t)
  219.     ,@(mapcar #'(lambda (font-name)
  220.                   (make-instance 'menu-item
  221.                     :menu-item-title font-name
  222.                     :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  223.                                                                 (list font-name)
  224.                                                                 :mode #$doFont))))
  225.               *font-list*)))
  226.  
  227. (defun size-menu-items ()
  228.   `(,(make-instance 'menu-item :menu-item-title "Da Size")
  229.     ,(make-instance 'menu-item :menu-item-title "-" :disabled t)
  230.     ,@(mapcar #'(lambda (font-size)
  231.                   (make-instance 'menu-item
  232.                     :menu-item-title (format nil "~D" font-size)
  233.                     :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  234.                                                                 (list font-size)
  235.                                                                 :mode #$doSize))))
  236.               '(1 7 19 37 53 71 89 107 131 151 173 193 223 239))
  237.     ,(make-instance 'menu-item :menu-item-title "-" :disabled t)
  238.     ,(make-instance 'menu-item
  239.        :menu-item-title "Smaller"
  240.        :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  241.                                                    '(-1)
  242.                                                    :mode #$addSize)))
  243.     ,(make-instance 'menu-item
  244.        :menu-item-title "Larger"
  245.        :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  246.                                                    '(1)
  247.                                                    :mode #$addSize)))))
  248.  
  249.  
  250. (defun style-menu-items ()
  251.   `(,(make-instance 'menu-item :menu-item-title "De Style")
  252.     ,(make-instance 'menu-item :menu-item-title "-" :disabled t)
  253.     ,@(mapcar #'(lambda (style)
  254.                   (make-instance 'menu-item
  255.                     :menu-item-title (string-capitalize style)
  256.                     :style style
  257.                     :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  258.                                                                 (list style)
  259.                                                                 :mode #$doFace))))
  260.               (mapcar #'car *style-alist*))))
  261.  
  262. (defun color-menu-items ()
  263.   `(,(make-instance 'menu-item :menu-item-title "De Color")
  264.     ,(make-instance 'menu-item :menu-item-title "-" :disabled t)
  265.     ,@(mapcar #'(lambda (color)
  266.                   (make-instance 'menu-item
  267.                     :menu-item-title ""
  268.                     :menu-item-colors (list :item-title color)
  269.                     :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  270.                                                                 nil
  271.                                                                 :font-color (eval color)
  272.                                                                 :mode #$doColor))))
  273.               '(720865 16741646 659455 16713464 16713989 524040 16776970))
  274.     ,(make-instance 'menu-item
  275.        :menu-item-title "-"
  276.        :disabled t)
  277.     ,(make-instance 'menu-item
  278.        :menu-item-title "Pick a color"
  279.        :menu-item-action #'(lambda () (te-set-font (view-named :te *test-w*)
  280.                                                    nil
  281.                                                    :font-color (user-pick-color)
  282.                                                    :mode #$doColor)))))
  283.  
  284. |#